perm filename PERSP.OL2[CMS,LCS] blob sn#720329 filedate 1983-07-17 generic text, type T, neo UTF8
C  APPLIES PERSPECTIVE TO DRAWING.  EDGE OF 'PAPER' MAY BE CURVED.
	IMPLICIT INTEGER(X,Y,Z)
	COMMON JHALF,F
	DIMENSION X1(800),Y1(800),Z1(800),X6(800)
	DIMENSION X2(200),Y2(200),Z2(200),X7(200),Y7(200)
	DIMENSION X3(800),Y3(800),X4(200),Y4(200)
	1  ,JJ(4000),X5(200),Y5(200)
 
	JHALF=0
1	FORMAT(' TYPE PICTURE NAME '$)
2	FORMAT(' TYPE CURVE NAME '$)
3	FORMAT(' TYPE OUTPUT NAME '$)
6	FORMAT(A5)
7	FORMAT(4I)
8	FORMAT(' TYPE X,Y FOR VANISHING POINT. '$)
9	FORMAT(' TYPE FORESHORTENING FACTOR. '$)
13	FORMAT(6F)
14	FORMAT(6I)
400	FORMAT(' LEFT=',I4,' RT=',I4,' TOP=',I4,' BOT='I4)
401	FORMAT(' TYPE X,Y FOR LOWER LEFT CORNER, X FOR RIGHT CORNER,'/
	1' X,Y FOR UPPER LEFT CORNER  '$)
C ASSUMES LEVEL BOTTOM FOR 'PIECE OF PAPER'
4	TYPE 1
	ACCEPT 6,NM1
	TYPE 2
	ACCEPT 6,NM2
	XL=9999
	XR=-XL
	YT=XR
	YB=XL
20	REWIND 1
	REWIND 20
	CALL IFILE(1,NM1)
	CALL IFILE(20,NM2)
	DO 30 KT=1,800
	READ(1,7,END=21)LT,X1(KT),Y1(KT),Z1(KT)
	X=X1(KT)
	Y=Y1(KT)
	IF(X.LT.XL)XL=X
	IF(X.GT.XR)XR=X
	IF(Y.LT.YB)YB=Y
30	IF(Y.GT.YT)YT=Y
C FIND OUTER DIMENSIONS OF PICTURE
21	KT=KT-1
C NOW KT = TOTAL VECTORS 
	J=X2(1)
	JB=J
	TYPE 400,XL,XR,YT,YB
	LB=Y2(1)
	LT=L
	DO 40 K=1,800
	READ(20,7,END=22)LT,X2(K),Y2(K),Z2(K)
	N=X2(K)
	IF(N.LT.J)J=N
	IF(N.GT.JB)JB=N
C ASSUMES BASE LINE IS LEVEL FOR NOW
	N=Y2(K)
	IF(N.LT.LB)LB=N
40	IF(N.GT.LT)LT=N
C GETS TOP AND BOT.  LT,LB
22	K=K-1
CC	IF(LB.GE.0)GO TO 200
CC	DO 201 J=1,K
CC201	Y2(J)=Y2(J)-LB
CC	DO 202 J=1,KT
CC202	Y1(J)=Y1(J)-LB
C SHIFT ALL TO Y POSITIVE IF ANY NEG POINTS
200	CALL DPYSET(1,JJ,4000)
  	CALL DRWIT(X2,Y2,Z2,K)
  	CALL DRWIT(X1,Y1,Z1,KT)
23	FORMAT(' HORIZONTAL POINTS ARE ',2I4)
24	FORMAT('  VERTICAL  POINTS ARE ',2I4)
C	TYPE 23,J,JB
C	TYPE 24,LB,LT
C ASSUMES TOP AND BOT OF CURVE ARE AT X=0, BOT AT Y=0.
	TYPE 401
	ACCEPT 14,XL,YB,XR,XL2,YT
	FA=LT-LB
C HEIGHT OF CURVE  (LB SHOULD BE 0)
	FB=YT-YB
C HEIGHT OF 'PIECE OF PAPER' (YB SHOULD BE 0)
	G=FB/FA
C FACTOR FOR SIZE DIFFERENCE BETWEEN PAPER AND CURVE
	LT=LT*G
	LB=LB*G
	XL=XH*G
	XR=XR*G
	YT=YT*G
	YB=YB*G
* SCALE EVERYTHING DOWN
	FC=XL2-XL
C OFFSET TO TOP OF SLANTED 'PIECE OF PAPER'
25	DO 15 J=1,K
	PC=(Y2(J)-LB)/FA
C % OF WAY UP FROM BOT.
	Y7(J)=G*Y2(J)
C EXPAND Y TO FIT PAPER
	Y4(J)=Y7(J)
	X7(J)=X2(J)*G+FC*PC
C EXPAND X BY SAME FACTOR AND TILT IF NECESSARY
15	X4(J)=X7(J)+XR
C SET UP RIGHT SIDE OF PIECE OF PAPER
	CALL DRWIT(X7,Y7,Z2,K)
	CALL DRWIT(X4,Y4,Z2,K)
C  NOW BEND DRAWING TO FIT GIVEN CURVE
	J=1
500	S=X1(J)
	T=Y1(J)
	DO 501 L=1,K-1
C ASSUMES CURVE GOES BELOW AND ABOVE PICTURE
	R=Y7(L)
	RR=Y7(L+1)
	IF(T.LT.R.OR.T.GT.RR)GO TO 501
C	H=X7(L)-X7(L+1)
	HA=X7(L)
	H=X7(L+1)-HA
C	G=(R-T)/(Y2(L+1)-T)
	G=(R-T)/(R-Y7(L+1))
C G=% OF WAY BETWEEN POINTS
	X6(J)=HA+S+H*G
	J=J+1
	IF(J.LE.KT)GO TO 500
	GO TO 502
501	CONTINUE
502	CALL DRWIT(X6,Y1,Z1,KT)
	TYPE 8
	ACCEPT 7,X,Y
	CALL AIVECT(X7(K)-100,Y7(K))
	CALL AVECT(X-100,Y)
	CALL AVECT(X7(1)-100,Y7(1))
	CALL DPYOUT(1)
C SHOWS VANISHING POINT
	TYPE 9
	ACCEPT 13,F
	HA=Y7(K)-Y
C HEIGHT FROM VP TO TOP OF RECT.
	HB=Y7(1)-Y
C HEIGHT FROM VP TO BOT OF RECT.
	DL=X-X7(1)
C LENGTH FROM LEFT EDGE OF RECT. TO VP
	M1=1
C GET FIRST POINTS
C G,LT=TOP OF RECT.  H,LB=BOT OF RECT.
	G=LT
	H=LB
	D=G-H
C D=HEIGHT OF RECT.
27	DO 26 J=1,K
26	CALL FORSH(X4(J),Y4(J),X5(J),Y5(J),LB,D,X,Y,DL,HA,HB)
	CALL DRWIT(X5,Y5,Z2,K)
28	DO 10 M1=1,KT
10	CALL FORSH(X6(M1),Y1(M1),X3(M1),Y3(M1),LB,D,X,Y,DL,HA,HB)
12 	CALL DRWIT(X3,Y3,Z1,KT)
300	FORMAT(' WRITE FILE? '$)
	TYPE 300
	ACCEPT 6,J
	IF(J.NE.'Y')GO TO 301
	TYPE 3
	ACCEPT 6,J
	CALL OFILE(21,J)
	IF(JHALF.NE.0)GO TO 304
	DO 302 J=1,KT
302	WRITE(21,7)J,X3(J),Y3(J),Z1(J)
C WRITES FILE TO BE USED WITH 'RE' IN THE DRW PROGRAM.
	J=KT
	DO 306 JK=1,K
	J=J+1
306	WRITE(21,7)J,X5(JK),Y5(JK),Z2(JK)
	DO 307 JK=1,K
	J=J+1
307	WRITE(21,7)J,X7(JK),Y7(JK),Z2(JK)
	J=J+1
	JK=1
	WRITE(21,7)J,X5(1),Y5(1),JK
	J=J+1
	JL=0
	WRITE(21,7)J,X7(1),Y7(1),JL
	J=J+1
	WRITE(21,7)J,X5(K),Y5(K),JK
	J=J+1
	WRITE(21,7)J,X7(K),Y7(K),JL
303	JHALF=0
	END FILE 21
301	CALL HYDPOG(1)
	GO TO 200
304	DO 305 J=1,KT
C HALF SIZE IF X OR Y .GE.1000
	LX=X3(J)/2
	LY=Y3(J)/2
305	WRITE(21,7)J,LX,LY,Z1(J)
	GO TO 303
	END 

	SUBROUTINE DRWIT(X,Y,Z,K)
	INTEGER X,Y,Z
	DIMENSION X(1),Y(1),Z(1)
	DO 1 J=1,K
	IF(Z(J).EQ.0)GO TO 2
	CALL AIVECT(X(J)-100,Y(J))
	GO TO 1
2 	CALL AVECT(X(J)-100,Y(J))
1 	CONTINUE
	CALL DPYOUT(1)
	END

	SUBROUTINE FORSH(XA,YA,XB,YB,LB,D,X,Y,DL,HA,HB)
	IMPLICIT INTEGER (X,Y)
	COMMON JHALF,F
10	RZ=(YA-LB)/D
C RZ= THIS POINT % OF HEIGHT IN RECT.
C NOW FIND HEIGHT IN RE. TO VANISHING POINT.
	XZ=X-XA
	XZ=XZ*(XZ**F)/(DL**F)
	A=XZ/DL
11	RQ=A*HA+Y
C POINT OF INTERSECTION WITH TOP LINE TO VP
	RR=A*HB+Y
C POINT OF INTERSECTION WITH BOT LINE TO VP
	DQ=RQ-RR
C LENGTH OF INTERSECTING VERTICAL SEGMENT
	LY=RZ*DQ+RR
	IF(IABS(LY).GE.1000)JHALF=-1
	YB=LY
C VERTICAL POINT, SCALED TO VP.
	LX=X-XZ
	IF(IABS(LX).GE.1000)JHALF=-1
	XB=LX
C NO X CHANGE FOR TIME BEING
	END